home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / sml_nj / 93src.lha / src / cps / cpsprint.sml < prev    next >
Encoding:
Text File  |  1993-01-27  |  4.9 KB  |  165 lines
  1. (* Copyright 1989 by AT&T Bell Laboratories *)
  2.  
  3. signature CPS_PRINT =
  4. sig
  5.   val showfun : (string -> unit) -> Access.lvar * Access.lvar list * CPS.cexp
  6.                 -> unit
  7.   val show : (string -> unit) -> CPS.cexp -> unit
  8. end
  9.  
  10. structure CPSprint : CPS_PRINT =
  11. struct
  12.  
  13. open CPS
  14.  
  15. fun lookerName P.! = "!"
  16.   | lookerName P.gethdlr = "gethdlr"
  17.   | lookerName P.subscript = "subscript"
  18.   | lookerName P.subscriptf = "subscriptf"
  19.   | lookerName P.getvar = "getvar"
  20.   | lookerName P.deflvar = "deflvar"
  21.   | lookerName P.ordof = "ordof"
  22.   | lookerName P.getspecial = "getspecial"
  23.  
  24. fun branchName P.boxed = "boxed"
  25.   | branchName P.unboxed = "unboxed"
  26.   | branchName P.< = "<"
  27.   | branchName P.<= = "<="
  28.   | branchName P.> = ">"
  29.   | branchName P.>= = ">="
  30.   | branchName P.ieql = "ieql"
  31.   | branchName P.ineq = "ineq"
  32.   | branchName P.lessu = "lessu"
  33.   | branchName P.gequ = "gequ"
  34.   | branchName P.feql = "feql"
  35.   | branchName P.fge = "fge"
  36.   | branchName P.fgt = "fgt"
  37.   | branchName P.fle = "fle"
  38.   | branchName P.flt = "flt"
  39.   | branchName P.fneq = "fneq"
  40.  
  41. fun setterName P.store = "store"
  42.   | setterName P.unboxedupdate = "unboxedupdate"
  43.   | setterName P.boxedupdate = "boxedupdate"
  44.   | setterName P.update = "update"
  45.   | setterName P.updatef = "updatef"
  46.   | setterName P.sethdlr = "sethdlr"
  47.   | setterName P.setvar = "setvar"
  48.   | setterName P.uselvar = "uselvar"
  49.   | setterName P.setspecial = "setspecial"
  50.  
  51. fun arithName P.* = "*"
  52.   | arithName P.+ = "+"
  53.   | arithName P.- = "-"
  54.   | arithName P.div = "div"
  55.   | arithName P.fadd = "fadd"
  56.   | arithName P.fdiv = "fdiv"
  57.   | arithName P.fmul = "fmul"
  58.   | arithName P.fsub = "fsub"
  59.   | arithName P.~ = "~"
  60.   | arithName P.floor = "floor"
  61.   | arithName P.round = "round"
  62.  
  63. fun pureName P.length = "length"
  64.   | pureName P.objlength = "objlength"
  65.   | pureName P.makeref = "makeref"
  66.   | pureName P.rshift = "rshift"
  67.   | pureName P.lshift = "lshift"
  68.   | pureName P.orb = "orb"
  69.   | pureName P.andb = "andb"
  70.   | pureName P.xorb = "xorb"
  71.   | pureName P.notb = "notb"
  72.   | pureName P.real = "real"
  73.   | pureName P.subscriptv = "subscriptv"
  74.   | pureName P.gettag = "gettag"
  75.   | pureName P.mkspecial = "mkspecial"
  76.  
  77.  
  78. fun show0 say =
  79.   let fun sayv(VAR v) = say(Access.lvarName v)
  80.         | sayv(LABEL v) = say("(L)" ^ Access.lvarName v)
  81.     | sayv(INT i) = say("(I)" ^ makestring i)
  82.     | sayv(REAL r) = say r
  83.     | sayv(STRING s) = (say "\""; say s; say "\"")
  84.       fun sayvlist [v] = sayv v
  85.         | sayvlist nil = ()
  86.     | sayvlist (v::vl) = (sayv v; say ","; sayvlist vl)
  87.       fun saypath(OFFp 0) = ()
  88.     | saypath(OFFp i) = (say "+"; say(makestring i))
  89.     | saypath(SELp(j,p)) = (say "."; say(makestring j); saypath p)
  90.       fun sayvp (v,path) = (sayv v; saypath path)
  91.       fun saylist f [x] = f x | saylist f nil = () 
  92.     | saylist f (x::r) = (f x; say ","; saylist f r)
  93.       fun indent n =
  94.     let fun space 0 = () | space k = (say " "; space(k-1))
  95.         fun nl() = say "\n"
  96.             val rec f =
  97.          fn RECORD(k,vl,v,c) => (
  98.           space n;
  99.           case k of Access.RK_VECTOR => say "#{" | _ => say "{";
  100.           saylist sayvp vl; say "} -> ";
  101.           sayv(VAR v);
  102.           nl(); f c)
  103.           | SELECT(i,v,w,c) =>
  104.             (space n; sayv v; say "."; say(makestring i); say " -> ";
  105.              sayv(VAR w); nl(); f c)
  106.           | OFFSET(i,v,w,c) =>
  107.             (space n; sayv v; say "+"; say(makestring i); say " -> ";
  108.             sayv(VAR w); nl(); f c)
  109.           | APP(w,vl) => 
  110.             (space n; sayv w; say "("; sayvlist vl; say ")\n")
  111.           | FIX(bl,c) =>
  112.             let fun g(v,wl,d) = 
  113.                 (space n; sayv(VAR v); say "("; 
  114.                  sayvlist (map VAR wl);
  115.                  say ") =\n"; indent (n+3) d)
  116.              in app g bl; f c
  117.             end
  118.           | SWITCH(v,c,cl) =>
  119.            let fun g(i,c::cl) =
  120.             (space(n+1); say(makestring(i:int));
  121.              say " =>\n"; indent (n+3) c; g(i+1,cl))
  122.              | g(_,nil) = ()
  123.             in space n; say "case "; sayv v; say "  ["; 
  124.                say(makestring(c));
  125.                say "] of\n"; 
  126.                g(0,cl)
  127.            end
  128.           | LOOKER(i,vl,w,e) =>
  129.            (space n; say(lookerName i); say "("; sayvlist vl;
  130.             say ") -> "; sayv(VAR w); nl(); f e)
  131.           | ARITH(i,vl,w,e) =>
  132.            (space n; say(arithName i); say "("; sayvlist vl;
  133.             say ") -> "; sayv(VAR w); nl(); f e)
  134.           | PURE(i,vl,w,e) =>
  135.            (space n; say(pureName i); say "("; sayvlist vl;
  136.             say ") -> "; sayv(VAR w); nl(); f e)
  137.           | SETTER(i,vl,e) =>
  138.            (space n; say(setterName i); say "("; sayvlist vl;
  139.             say ")"; nl(); f e)
  140.           | BRANCH(i,vl,c,e1,e2) =>
  141.                (space n; say "if "; say(branchName i);
  142.              say "("; sayvlist vl; say ") ["; 
  143.                          sayv(VAR c); say "] then\n";
  144.             indent (n+3) e1;
  145.             space n; say "else\n";
  146.             indent (n+3) e2)
  147.          in f
  148.         end
  149.  in  indent
  150.  end
  151.  
  152. fun showfun say (f,vl,e) =
  153. let   
  154.       fun sayvlist [v] = say(Access.lvarName v)
  155.         | sayvlist nil = ()
  156.     | sayvlist (v::vl) = (say(Access.lvarName v); say ","; sayvlist vl)
  157.  in 
  158.  (say(Access.lvarName f); say "("; sayvlist vl; say ") =\n";
  159.   show0 say 3 e)
  160. end
  161.  
  162. fun show say = show0 say 0
  163.  
  164. end  (* structure CPSprint *)
  165.